home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / front_end / user_error.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  9.3 KB  |  256 lines
  1. (herald (front_end user_error)
  2.   (env t (orbit_top defs)))
  3.  
  4. ;;; Error and warning messages for the lusers.
  5.  
  6. ;;;                    USER-MESSAGE and friends
  7. ;;;============================================================================
  8.  
  9. ;;; Various aliases for PRINT-USER-MESSAGE.
  10.  
  11. (define (user-message type string action . args)
  12.   (real-user-message type string action args))
  13.  
  14. (define (real-user-message type string action args)
  15.   (print-user-message type string action *current-module-exp* args))
  16.  
  17. (define (user-message-with-location type loc string action . args)
  18.   (print-user-message type string action loc args))
  19.  
  20. (define (user-message-without-location type string action . args)
  21.   (print-user-message type string action nil args))
  22.  
  23. ;;; TYPE is either ERROR or WARNING, STRING is a format string, ACTION is
  24. ;;; either #F or a format string describing any action taken, LOC is #F or a
  25. ;;; module-exp structure.  ARGS is a list of arguments for the format strings.
  26. ;;;
  27. ;;; This is an internal call, use one of the above instead.
  28.  
  29. (define (print-user-message type string action loc args)
  30.   (apply format
  31.          *noise+error*
  32.          `("~%;** ~A: " ,string 
  33.            . ,(if action `("~%;   Action: " ,action) nil))
  34.          (case type
  35.            ((warning) "Warning")
  36.            ((error) "Error")
  37.            (else (bug "unknown type of user message ~S" type)))
  38.          args)
  39.   (if loc (print-location *noise+error* loc)))
  40.  
  41. ;;; Print out the something to indicate the source code corresponding to
  42. ;;; MODULE-EXP.
  43.  
  44. (define (print-location stream module-exp)
  45.   (format stream "~&;   Location: in ")
  46.   (let ((def (module-exp-def module-exp)))
  47.     (cond ((not def)
  48.            (print-one-line (module-exp-source module-exp) stream)
  49.            (newline stream))
  50.           ((variable? def) 
  51.            (format stream "definition of ~S~%" (variable-name def)))
  52.           (else
  53.            (format stream "definition of ~S~%" def)))))
  54.  
  55. ;;; Printing out a minimally reconstructed version of a lambda's source code.
  56.  
  57. (define (show-lambda node)
  58.   (iterate loop ((vars (reverse! (map variable-name
  59.                                  (cdr (lambda-variables node)))))
  60.                  (res (if (lambda-rest-var node)
  61.                           (variable-name (lambda-rest-var node))
  62.                           '())))
  63.     (cond ((null? vars)
  64.            (format nil "(LAMBDA ~S ...)" res))
  65.           (else
  66.            (loop (cdr vars) (cons (car vars) res))))))
  67.  
  68.  
  69. ;;;                6000000 possible user errors   
  70. ;;;=============================================================================
  71. ;;; I do not like this interface.
  72.  
  73. (define (fix-user-error call string . args)
  74.   (let ((message (apply format nil string args)))
  75.     (real-user-message 'error
  76.                        message
  77.                        "replacing with undefined effect"
  78.                        '())
  79.     (replace-call-with-undefined-effect call message)))
  80.  
  81. (define (fix-early-binding-error ref string . args)
  82.   (let ((message (apply format nil string args)))
  83.     (real-user-message 'warning
  84.                        message
  85.                        nil
  86.                        '())
  87.     (replace-with-free-variable ref)))
  88.  
  89. (define (fix-call-to-lambda call proc)
  90.   (fix-user-error call
  91.                   "wrong number of arguments in a call to ~A"
  92.                   (show-lambda proc)))
  93.  
  94. (define (fix-call-to-literal call value)
  95.   (fix-user-error call "call to literal ~A" value))
  96.  
  97. (define (fix-call-to-bound-lambda call var val)
  98.   (fix-user-error call
  99.                   "wrong number of arguments in a call to ~S bound to ~A"
  100.                   (variable-name var)
  101.                   (show-lambda val)))
  102.  
  103. (define (fix-call-to-early-bound-literal ref)
  104.   (fix-early-binding-error ref
  105.                            "call to ~S which is bound to a literal" 
  106.                            (variable-name (reference-variable ref))))
  107.  
  108. (define (fix-call-to-early-bound-proc ref)
  109.   (fix-early-binding-error ref
  110.                            "wrong number of arguments in a call to ~S"
  111.                             (variable-name (reference-variable ref))))
  112.  
  113. (define (fix-early-bound-type-error ref)
  114.   (fix-early-binding-error ref
  115.                            "~S is of the wrong type"
  116.                             (variable-name (reference-variable ref))))
  117.  
  118. (define (fix-call-to-values call type)
  119.   (let ((count (fx+ -1 (length (call-args call)))))
  120.     (fix-user-error call
  121.                     '"returning ~A value~P when ~A expected"
  122.                     (if (fx= '0 count) '"no" count)
  123.                     count
  124.                     (values-error-string type))))
  125.  
  126. (define (fix-call-to-receive-values call type)
  127.   (let ((count (length (call-args call))))
  128.     (fix-user-error call
  129.                     '"returning ~A value~P when ~A expected"
  130.                     (if (fx= '0 count) '"no" count)
  131.                     count
  132.                     (values-error-string type))))
  133.  
  134. (define (values-error-string type)
  135.   (let ((n-ary? (cadr type))
  136.         (count (caddr type)))
  137.     (cond ((and (not n-ary?) (fx= count '0))
  138.            '"none are")
  139.           ((and (not n-ary?) (fx= count '1))
  140.            '"one is")
  141.           ((not n-ary?) 
  142.            (format nil '"~D are" count))
  143.           ((fx= count '1)
  144.            '"at least one is")
  145.           (else
  146.            (format nil '"at least ~D are" count)))))
  147.  
  148. (define (fix-early-bound-variable-error ref type)
  149.   (cond ((not (eq? (node-role ref) call-proc))
  150.          (fix-early-bound-type-error ref))
  151.         ((eq? type 'literal)
  152.          (fix-call-to-early-bound-literal ref))
  153.         (else
  154.          (fix-call-to-early-bound-proc ref))))
  155.  
  156.  
  157. ;;;                   removing errors from the tree
  158. ;;;============================================================================
  159.  
  160. ;;; Replace CALL with an undefined effect that will print out MESSAGE when
  161. ;;; encountered at run time.
  162.  
  163. (define (replace-call-with-undefined-effect call message)                
  164.   (let ((new-call (create-call-node 3 1)))
  165.     (relate call-proc new-call (create-primop-node primop/undefined-effect))
  166.     (relate (call-arg 1)
  167.             new-call
  168.             (if (fx= 0 (call-exits call))
  169.                 (detach (call-proc call))
  170.                 (detach ((call-arg 1) call))))
  171.     (relate (call-arg 2) new-call (create-literal-node message))
  172.     (replace call new-call)))
  173.  
  174. (define (containing-definition-name node)
  175.   (let ((def (module-exp-def *current-module-exp*)))
  176.     (cond ((not def)       "at top level")
  177.           ((variable? def) (variable-name def))
  178.           (else            def))))
  179.            
  180. ;;; Replace REF with a reference to a free variable of the same name.  This 
  181. ;;; is used to correct early binding errors.
  182.  
  183. (define (replace-with-free-variable ref)
  184.   (replace ref
  185.            (create-reference-node
  186.             (get-free-alias-variable (reference-variable ref)))))
  187.  
  188. (define (get-free-alias-variable var)
  189.   (cond ((get-child-variable var 'free-alias)
  190.          => identity)
  191.         (else
  192.          (let ((new-var (create-variable (variable-name var))))
  193.            (add-child-variable var new-var 'free-alias)
  194.            new-var))))
  195.  
  196.  
  197. ;;;                     CONTAINING-DEFINITION
  198. ;;;============================================================================
  199. ;;; This is debugging procedure for printing out the location of a node.  If
  200. ;;; the front end is running the form can be gotten directly from
  201. ;;; *CURRENT-MODULE-EXP*.  If not, it tries to find a definition whose value
  202. ;;; contains NODE by following the continuations.
  203. ;;;
  204. ;;; This should be in some other file.  It is no longer used in this one.
  205.  
  206. (define (containing-definition node)
  207.   (cond (*current-module-exp*
  208.          => (lambda (exp)
  209.               (fresh-line (standard-output))
  210.               (print-one-line (standard-output) module-exp-form)
  211.               (new-line (standard-output))))
  212.         ((and (call-node? node)
  213.               (known-variable-definition? node))
  214.          (format t "~&At the definition of ~S~%"
  215.                      (variable-name
  216.                       (reference-variable ((call-arg 2) node)))))
  217.         (else
  218.          (real-containing-definition node)))
  219.   *repl-wont-print*)
  220.  
  221. (define (real-containing-definition node)
  222.   (iterate loop ((node node))
  223.     (let ((parent (node-parent node)))
  224.       (cond ((not (node? parent))
  225.              (format t "~&at top level~%"))
  226.             ((not (and (call-node? parent)
  227.                        (known-variable-definition? parent)))
  228.              (loop parent))
  229.             ((eq? node ((call-arg 3) parent))
  230.              (format t "~&in the definition of ~S~%"
  231.                      (variable-name
  232.                       (reference-variable ((call-arg 2) parent)))))
  233.             ((eq? node ((call-arg 1) parent))
  234.              (format t "~&at top level after the definition of ~S~%"
  235.                      (variable-name
  236.                       (reference-variable ((call-arg 2) parent)))))
  237.             (else
  238.              (format t "~&at top level~%"))))))
  239.  
  240. (define (known-variable-definition? call)
  241.   (and (variable-definition? call)
  242.        (neq? 'set
  243.              (primop.definition-variant (known-primop (call-proc call))))))
  244.  
  245. ;;;; Useful debugging procedure
  246. ;(define (show-defs node)
  247. ;  (iterate loop ((node node))
  248. ;    (cond ((lambda-node? node)
  249. ;           (let ((def (containing-definition node)))
  250. ;             (format t "~&~D ~S~%" 
  251. ;                       (object-hash node)
  252. ;                       (if def (variable-name def) 'top-level))
  253. ;             (walk loop (call-proc+args (lambda-body node)))))
  254. ;          ((call-node? node)
  255. ;           (walk loop (call-proc+args node))))))
  256.